package Sgdb::CommandPrompt ;

use Sgdb::GdbExt ;

use Sgdb::Utils qw( :DEFAULT
                    menu_pop_common_View
                    menu_pop_common_Edit
                    bind_search_mechanism
                    focus_on
                    bypass_busy_for_interrupter
                    localconfig
                    info_line_lookup
                    ) ;
# pragmas for all
use warnings ;
use strict ;
use integer ;
use bytes ;

my @last_completions ;
my $last_completion_command = '' ;
my @command_history ;
my $command_history_current = '' ;
my $command_history_index   = 0  ;
my $initial_timeout ;
# our $semaphore ;
my $secretip_rexp ;

my $text ;
my $interrupter ;
our $stopit ;
our $in_multi_gdb_cmd ;

my $gdb ;
my %gdb ;

init() ;

sub init {

    $SIG{PIPE} = \&signal_PIPE_handle ;
    if ( my $si = $ENV{symmipSeCrEtIP} ) {
        $secretip_rexp = qr/\Q$si/ ;
    }

    #     $SIG{INT}  = \&signal_INT_handle ;
    # Algo: two signals generators = deadlocks
    # -- OBSOLETE: I want this sgdb to be close for C-c --

#      if ( eval { require Thread::Semaphore } ) {

#          $semaphore = new Thread::Semaphore ;
#                                  # Algo: if this is not a multi threading Perl
#                                  # then probably I don't need this semaphore
#                                  # anyway.
#          eval { require Thread::Signal } ;
#                                  # Algo: again, if it can't use it, probably it
#                                  # doesn't need it.
#      }
    # OBSOLETE: Perlon: Tk wouldn't obey those multi threads semaphores

    1 ;
}

sub new {
    my $self = shift or die "whoami" ;
    my $topf = shift or die "top frame needed" ;

    my $frame = $topf  -> Frame () ;
    my $fram1 = $frame -> Frame () ;

    my $serial  = $fram1->Entry (-state       => 'disabled',
                                 -background  => 'grey90',
                                 -width       => 5,
                                 -foreground  => 'blue4',
                                 -relief      => 'raised' ,
#                                 -invalidcommand => [$frame, 'bell'] ,
                                 -validate    => 'key',
                                 -vcmd        => sub {$_[0] =~ /^\d*$/},
                                 -textvariable => \$command_history_index ,
                                 ) ;

    balloonset $serial => <<DoC ;
The number is the current command serial number.
Type \"?\" to see how to navigate through the 
command history list. If you edit the current 
serial number and press Enter, you will recall 
a previous command and display it in the 
command line field.
DoC
#    $commands = $fram1->BrowseEntry (-state       => 'disabled',
    my $command = $fram1->Entry (-state       => 'disabled',
                                 -background  => 'grey90',
                                 -foreground  => 'blue4',
                                 ) ;

#      $command -> configure ( -listcmd => [\&show_list_history, $command]
#                                    ) ;


    balloonset $command => <<DoC ;
This is the Sgdb CLI field that takes gdb and Sgdb-specific 
commands. Press \"space + Tab\" to display all supported Sgdb 
commands and type \"help <command>\" for more details on <command>. 
You must be connected to the target!
DoC
             $text = ( pref ( 'command-prompt-show-scrollbars' ) ?
              $frame->Scrolled ( 'ROText',
                                 -width       => 60,
                                 -height      => 15,
                                 -background  => "grey90",
                                 -foreground  => "blue4",
                                 -wrap        => 'none',
                                 ) :
              $frame->ROText (
                              -width       => 60,
                              -height      => 15,
                              -background  => "grey90",
                              -foreground  => "blue4",
                              -wrap        => 'none',
                              )
              ) ;

#    balloonset $text => <<DoC ;
#This pane displays the status of each 
#request issued via the Sgdb GUI. 
#When you click a button or type 
#a command in the Sgdb window, the 
#corresponding action is reflected 
#in a status message in this pane. 
#Use this information to monitor 
#your debugging session.
#DoC

 $text->insert ('1.1' , explain_me(), ) ;

    pref_tags $text, 'command-prompt', qw/prompt command result completions switch clicked/ ;
    $interrupter = $fram1 -> Button ( -state => 'disabled',
                                      -cursor => 'arrow',
                                      -text => 'INT' ,
                                      -width => 3,
                                      -command => [\&signal_from_interrupter, $text],
                                      ) ;

    bypass_busy_for_interrupter ( $interrupter ) ;


    balloonset $interrupter => <<DoC ;
Click INT to suspend the 
current command execution. 
DoC

    {   # bindings
        # Perlon: some bindings are actualy
        # clusters. lookup "Advance Perl Programing".

        my ($t, $e, $s)  = ($text, $command, $serial) ;

        $e->bind ("<Up>"    ,       [\&command_history, -1             ]) ;
        $e->bind ("<Control-p>",    [\&command_history, -1             ]) ;
        $e->bind ("<Down>"  ,       [\&command_history, +1             ]) ;
        $e->bind ("<Control-n>",    [\&command_history, +1             ]) ;
        $e->bind ("<Return>",       [\&exec_entry_command, $t,         ]) ;
        $e->bind ("<Control-j>",    [\&exec_entry_command, $t,         ]) ;
        $e->bind ("<KeyPress-Tab>", [\&complete, $t                    ]) ;
#          $e->bind ("<Control-c>",    sub { signal_from_interrupter ($t) }  ;

        $s->bind ("<FocusOut>",     [\&command_history_goto, $e,       ]) ;
        $s->bind ("<Return>"  ,     [\&exec_history_command, $e, $t    ]) ;
        $s->bind ("<Up>"    ,       sub { command_history  ( $e, -1   )}) ;
        $s->bind ("<Down>"  ,       sub { command_history  ( $e, +1   )}) ;
        $s->bind ("<Home>" ,        [\&command_history_goto, $e, 'home']) ;
        $s->bind ("<End>",          [\&command_history_goto, $e, 'end' ]) ;
        $s->bind ("<Prior>",        [\&command_history_goto, $e, '-10' ]) ;
        $s->bind ("<Next>",         [\&command_history_goto, $e, '+10' ]) ;
        $s->bind ("<Meta-Up>",     sub {}) ;
        $s->bind ("<Meta-Down>",   sub {}) ;
    }

    nice_popup_menu_for( $text ) ;

    $serial      -> pack (-fill => 'none', -side => 'left'  ) ;
    $interrupter -> pack (-fill => 'none', -side => 'right' ) ;
    $command     -> pack (-fill => 'x',    -side => 'left', -expand => 1 ) ;
    $fram1       -> pack (-fill => 'x',                     ) ;
    $text        -> pack (-fill => 'both', -side => 'top' , -expand => 1 ) ;

    bind_search_mechanism $text, $command ;

    my $take_focus = sub { focus_on $command if
                             pref 'command-prompt-grab-focus' } ;
    hook_add ( 'new-symbol-file'       => [\&new_symbol_file,     $text, $interrupter, $serial, $command ],
               'invalid-symbol-file'   => [\&invalid_symbol_file, $text, $interrupter, $serial, $command ],
               'show-completions'      => [\&show_completions,    $text ] ,
               'new-symbol-file'       => $take_focus,
               'new-target-remote'     => $take_focus,
               'target-was-switched'   => $take_focus,

               'create-new-gdb'        => \&new_gdb,
               'create-new-multi-gdb'  => \&new_multi_gdb,
#                'target-symmetrix-chdir'=> \&target_symmetrix_chdir,
               'exec-multi-target-cmd' => \&exec_multi_target_cmd,
               'target-was-switched'   => \&save_directories_list,
               );

    bindkey 'C-u'       => sub { focus $command         } => ' Focus on Command Prompt ' ;
    bindkey 'C-greater' => sub { gdb_exec_lock 'tfind'  } => ' (C->) tfind   (next trace frame)' ;
    bindkey 'C-less'    => sub { gdb_exec_lock 'tfind -'} => ' (C-<) tfind - (prev trace frame)' ;
    bindkey 'C-bracketright' => [\&associative_line, 1] => ' (C-]) associative source line - forward' ;
    bindkey 'C-bracketleft'  => [\&associative_line,-1] => ' (C-[) associative source line - backward' ;

    pref_reconfigure ( 'command-prompt-text' => $text ,
                       'command-prompt-command-entry' => $serial  => $command => $interrupter, 
                       ) ;
    $text -> bind ( '<Control-1>', [\&info_line_lookup, '', '', 'clicked' ]) ;

    $frame ;
}

sub associative_line {
    return unless istkwidget $text;
    my $inc ;
    $inc = shift || 1 ;
    $inc = shift || 1 if ref $inc ; # allow binding
    my $t = $text ;

    unless ( eval { $t -> index ( 'a-lookup' ) } ) {
        # Perlon: blach... where is $t -> markExists ( 'my-mark' )?
        # Algo: run once
        $t -> markSet ( 'a-lookup', 'end' ) ;
        hook_add 'open-source-file' => sub { $t -> markSet( 'a-lookup', 'end' ) } ;
    }

    my $i = $t -> index ( 'a-lookup' ) ;
    while ( 1 ) {
        $i = $t -> index ( "$i + $inc lines linestart" ) ;
        if ( $t -> compare ( $i, '==', '1.0' ) or
             $t -> compare ( $i, '==', 'end linestart') ) {
            $t -> bell ;
            last ;
        }
        my ($file, $line ) ;
        my $l = $t -> get ( $i => "$i lineend" ) ;
        if  ( 25 > length $l ) {
            next ;
        }
        elsif ( $l =~ m[^Line (\d+) of \"(.+?)\"] ) {
            ( $file, $line ) = ($2, $1 ) ;
        }
        elsif ( $l =~ m[at (\S+):(\d+)\s*$] ) {
            ( $file, $line ) = ($1, $2 ) ;
        }
        else {
            next ;
        }
        hook_run 'open-source-file', $file, $line ;
        $t -> markSet ( 'a-lookup', $i ) ;
        last ;
    }
}

#  sub show_list_history {

#      my $e = shift or return ;
#      my $s = $e -> get( ) ;

#      if ( $s  ) {

#          $e -> insert ( 0 => grep { $s eq substr $_, 0, length $s } @command_history ) ;
#      }
#      else {

#          $e -> insert ( 0 => @command_history ) ;
#      }
#  }

sub nice_popup_menu_for {

    my $t = shift ;
    my $m = $t->menu() ;

    my $sm_Edit  = $m -> Menu (-tearoff => 0, pref( 'pop-menu') ) ;
    menu_pop_common_Edit( $t, $sm_Edit ) ;
    my $sm_View  = $m -> Menu (-tearoff => 0, pref( 'pop-menu') ) ;
    menu_pop_common_View( $t, $sm_View ) ;
    my $sm_Clear = $m -> Menu (-tearoff => 0, pref( 'pop-menu') ) ;

    menu_fill ($sm_Clear, 'pop-menu',
               [ 'All', [$t, 'delete', '1.0', 'end -1 line']],
               [ 'Selection', sub {
                     if ($t -> tagRanges('sel')) {
                         $t -> delete( 'sel.first', 'sel.last') ;
                     }
                     else {
                         telthem "no selection was made" ;
                     }
                 }],
               [ 'History', sub {
                     $command_history_index = 0 ;
                     @command_history = () ;
                 } ],
              );

    $m -> configure ( -postcommand => [\&popup_menu_for_command_promot, $m, $t, $sm_Edit, $sm_View, $sm_Clear],
                      pref 'pop-menu'
                    ) ;
}

sub popup_menu_for_command_promot {

    my ( $m, $t, $sm_Edit, $sm_View, $sm_Clear ) = @_ ;

    $m -> delete( 0 => 'end' ) ;

    my $current = $t -> index ( 'current' ) ;
    my ($w, $sm_Qeury, $sm_Multi) ;


    if    ( grep {$_ eq 'sel'} $t -> tagNames( $current ) and
            $t -> compare ("sel.first + 2 lines", '>', "sel.last") ) {

        $w = $t -> get ( 'sel.first', 'sel.last') ;
        chomp $w ;              # just in case user selected too much
    }
    else {
        # $w = $t -> get ( "$current wordstart", "$current wordend" ) ;
        $w = text_current_word $t, $current;
    }

    if ( %gdb ) {

        my @names = keys %gdb ;
        my $current  = $gdb && $gdb -> { 'file' } ;
        push @names, $current if $current and ! grep {$_ eq $current} @names ;

        menu_fill
          ( $m, 'pop-menu',
            Multi =>
            [ 'Close All !', [\&hook_run_lock, 'invalid-symbol-file' ]],
            '-',
            ( map {[[ radiobutton =>
                      -label => $_ ,
                      -variable => \$current,
                      -command => [\&new_multi_gdb, $_],
                    ]]} sort @names
            ),
            '---' ) ;
    }

    my $lw = lc $w ;
    menu_fill
      ($m, 'pop-menu',
       ( iff $w =~ /\w/,
         Query =>
         ( $w =~ /^0x[\da-f]+$/gi ?
           ( [ "i line  *$w", [\&gdb_exec_lock, "i line *$w"]],
             [ "i scope *$w", [\&gdb_exec_lock, "i scope *$w"]],
             [ "tfind pc $w", [\&gdb_exec_lock, "tfind pc $w"]],
             [ "x/16x    $w", [\&gdb_exec_lock, "x/16x $w"]],
             '-',
             ["Find Symbol $w", [\&hook_run, 'symbol-lookup', $w]],
           ) :
           (( iff $w =~ /^\w+$/,
              [ "i line $w", [\&gdb_exec_lock, "i line $w" ]],
              [ "i addr $w", [\&gdb_exec_lock, "i address $w" ]],
              '-',
            ),
            [ "p    &($w)", [\&gdb_exec_lock, "p &($w)" ]],
            [ "p    *($w)", [\&gdb_exec_lock, "p *($w)" ]],
            [ "p/x  *($w)", [\&gdb_exec_lock, "p *($w)" ]],
           ),
         ),
         '-',
         [ "ptype  $w", [ \&gdb_exec_lock, "ptype $w" ]],
         [ "p      $w", [ \&gdb_exec_lock, "p $w" ]],
         [ "p*     $w", [ \&gdb_exec_lock, "p* $w" ]],
         [ "p/x    $w", [ \&gdb_exec_lock, "p/x $w" ]],
         '-',
         [ "Watch       $w", [\&hook_run_lock, 'add-watch', $w ]],
         [ "Find Symbol $w", [\&hook_run, 'symbol-lookup', $w ]],
         [ "Etags       $w", [\&hook_run, 'etags-lookup', $w ]],
         '---',
       ),
       Edit  => $sm_Edit,
       View  => $sm_View,
       '-',
       Clear => $sm_Clear,
       '---',
       [Help  => [\&hook_run, 'show-completions', explain_me()]],
      )
}

sub new_gdb {

    my $oldname ;

    if ( $gdb ) {

        hook_run 'target-was-detached', 'file', $oldname if
            $oldname = $gdb -> { 'file' } ;
#         destroy $gdb ;
    }

    telthem 'Activating gdb' ;

    $gdb = new Sgdb::GdbExt localconfig 'parameterize', @_ ;

    if (ref $gdb) {

        $gdb -> { 'is-alive'} = 1 ;
        $gdb -> { 'alldone' } = \&gdb_alldone ;
        $gdb -> { 'notyet'  } = \&gdb_notyet  ;
        $gdb -> { 'syren-v' } = localconfig 'get-emc-release', $gdb ;

        hook_run 'new-symbol-file' , $gdb -> { 'file' } ;

        welcome_msg() ;

        if ( %gdb ) {

            # Algo: if user chooses to activate an exiting 'file', maybe he just
            # wants to refresh the gdb entry (for not responding). else, I'll close
            # multi gdb sessions.

            if ( $oldname and exists $gdb{ $oldname } ) {

                telthem "clearing '$oldname' old gdb session" ;
                # well, it should be already destroyed by now..
                $gdb{ $oldname } = $gdb ;
            }
            else {

                telthem 'clearing all old gdb sessions' ;
                hook_run 'target-was-detached', 'all' ;
#                 map { destroy $_ } values %gdb ;
            }
        }

        if ( my $commands = pref 'gdb-initial-commands' ) {

            telthem "running initial commands" ;
            foreach my $cmd ( split ';', $commands ) {

                gdb_exec_lock $cmd, 20 ;
            }
        }
    }
    else {
        telthemloud ($gdb || "cant activate this gdb session" ) ;

        if ( %gdb ) {

            ($gdb) = values %gdb ;
            welcome_msg() ;
        }
        else {
            hook_run "invalid-symbol-file" ;
        }
    }
}

sub new_multi_gdb {

    my  $name = $_[ 0 ] or return telthemloud "unknown gdb" ;

    if ( $name eq 'file'  ) {
        $name = $_[ 1 ] or return telthemloud "unknown gdb" ;
    }
    else {
        unshift @_, 'file' ;
    }
    # Algo: a multi gdb item MUST be associated with a symbol file.
    # Note: shall I allow omitting 'symbol-file' just because I'm lazy, hubris and impatient?

    if ( $gdb ) {

        my $oldname = $gdb ? $gdb -> { 'file' } : '' ;

        if ( !  $oldname or
             -d $oldname ) {

            #            destroy $gdb ;
        }
        elsif ( $oldname eq $name ) {
            # fastest way out
            return ;
        }
        else {

            $gdb{$oldname} = $gdb ;
        }
    }

    if ( exists $gdb{ $name } ) {

        if    ( !       $gdb -> { 'file' }   ) {
            # nothing to save
#            destroy $gdb ;
        }
        elsif ( ! $gdb{ $gdb -> { 'file' } } ) {
            # Algo: although this 'file' wasn't open in multi_mode, I'll
            # prepare switching it into one. Chances are that's what the user meant.

            $gdb{ $gdb -> { 'file' } } = $gdb ;
        }

        $gdb = $gdb{ $name } ;

        welcome_msg () ;
        hook_run 'clear-all-disassembly' ;
        ex_gdb_exec ( '.' ) ;
        return ;
    }

    telthem "Activating multi gdb ($name)" ;

    my $tst = new Sgdb::GdbExt localconfig 'parameterize', @_ ;

    if ( ref $tst ) {

        $gdb = $tst ;
        $gdb -> { 'is-alive' } = 1 ;
        $gdb -> { 'alldone'  } = \&gdb_alldone ;
        $gdb -> { 'notyet'   } = \&gdb_notyet  ;
        $gdb -> { 'syren-v'  } = localconfig 'get-emc-release', $gdb ;

        hook_run 'new-symbol-file', $name unless keys %gdb ;
        $gdb{ $name } = $gdb ;

        welcome_msg () ;

        telthem 'done' ;
        1 ;
    }
    else {

        telthemloud ( $tst || ( "can't execute gdb! ", @_ ) ) ;
        $gdb = {} ;
        symbol_file_detached () ;
    }
}

sub ex_foreach_target_symmetrix(&;$) {
    my ($sub, $single) = @_;
    my ($currenttarget) = gdb_get( 'i symmetrix-targets' ) =~ /^Target.*\"(.*)\" \(cur/mi;
    my ($currentdirname) = $currenttarget =~ /[~:]*:(\w*) .*/;
    return $sub -> ($currentdirname) if $single ;
    my @targets = ex_target_symmetrix_list() ;
    my @res ;
    foreach my $dir ( @targets ) {
        my ($dirname) = $dir =~ /[~:]*:(\w*) .*/;
        ex_target_symmetrix_chdir ( $dir ) ;
        my $stop ;
        push @res, scalar $sub -> ($dirname, \$stop) ;
        last if $stop ;
    }
    ex_target_symmetrix_chdir ( $currenttarget ) if $currenttarget ;
    \@res
}

sub save_directories_list {
    my $l = shift || '';
    $l =~ /\"([^\n]+)\"\s*\(current\)/ ||
    $l =~ /\"([^\n]+)\"/  and
      $gdb -> {last_dir}{$1} = time ;
}

sub ex_target_symmetrix_list {
    my     @list = sort {$gdb->{last_dir}{$a} <=> $gdb->{last_dir}{$b}} keys %{$gdb->{last_dir}} ;
    return @list if wantarray ;
    return $list[0] ;
}

sub ex_target_symmetrix_chdir {
    # take advantage of the agent's chdir (protocol version 5 and up)
    my ($tar, $sshh) = @_ ;
    sub may_chdir {
        # 10.243.110.129:D07b qLOGHysfOUog 1nternal
        my $t = shift ;
        return unless $gdb -> {last_dir} and
          ! $gdb->{cannot_chdir} and
            $t =~ /^\s*([\.\w]+):(\w\w\w\w)\b/ ;
        my ($add, $ndir) = ($1, $2) ;
        return unless ( ex_target_symmetrix_list() )[0] =~ /^\s*([\.\w]+):(\w\w\w\w)\b/ ;
        return unless $add eq $1 ;
        $ndir
    } ;

    my $gdb_exec = $sshh ? \&gdb_exec_quiet : \&gdb_exec ;

    if( my $dir = may_chdir($tar) ) {
        my $res = $gdb_exec -> ("symm-chdir $dir") ;
        $res =~ /^\s*Target/m and return $res ; # good job
        $res =~ /S05|sgdb agent doesn't support this method|Undefined command/ and
          $gdb->{cannot_chdir} = 1;
    }

    $gdb_exec -> ("target symmetrix $tar") ;
}

sub complete {

    my ($e, $t) = @_ ;
    my $cmd = $e->get or return ;

    $gdb or return telthemloud ("no active debugger") ;

    if ($cmd eq $last_completion_command) {

        $cmd = $last_completion_command = shift @last_completions ;
        push @last_completions, $cmd ;
        $e->delete(0, 'end') ;
        $e->insert(0, $cmd ) ;
    }
    else {

        clear_completions($t) ;

        my @results = grep /\w/, split /^/, gdb_get("complete $cmd") ;
        chomp @results ;

        if    (@results == 0 ) {

            $t->see('end -4 chars') ;
            $t->insert('end',
                       "no completions for $cmd" => 'completions',
                       ) ;
        }
        elsif (@results == 1 ) {

            $e->delete(0,'end') ;
            $e->insert(0, $results[0]) ;
        }
        else {

            $cmd =~ s/^\s*// ;
            my $i = length ($cmd) - 1 ;
            $cmd = shift @results ;

            while($i++) {
                my $char = substr($cmd, $i, 1) ;
                last if grep
                {$i > length($_) or substr($_, $i, 1) ne $char }
                @results ;
            }

            $last_completion_command = substr($cmd, 0, $i) ;

            $e->delete(0,'end') ;
            $e->insert(0, $last_completion_command );

            @last_completions = ($cmd,  @results) ;

            my $upper_pos = $t->index('end -4 chars') ;
            $t->insert('end',
                       join ("\n",
                             "completions are:" ,
                             @last_completions ,
                             '')
                       => 'completions',
                       ) ;
            $t->see('end') ;
            $t->see("$upper_pos") ;
        }
    }
    $t->break ;
}

sub command_history {
    my ($e, $inc, $cmd) = @_ ;

    $command_history_current = $e->get if $command_history_index == @command_history ;

    $command_history_index += $inc ;

    $command_history_index = @command_history if
        $command_history_index > @command_history ;
    $command_history_index = 0 if
        $command_history_index < 0 ;

    if ( $command_history_index == @command_history ) {
        $cmd = $command_history_current ;
    }
    else {
        $cmd = $command_history[ $command_history_index ] ;
    }

    $e->delete(0, 'end') ;
    $e->insert(0, $cmd ) ;
}

sub command_history_goto {

    my ($s, $e, $cmd) = @_ ;

    if    (! $cmd ) {

        $command_history_index = $s -> get ;
        # Perlon: don't know what will happen first,
        # this function call or '-textvariable' update.
        # So, make sure.
    }
    elsif ( $cmd eq 'home' ) {

        $command_history_index = 0 ;
    }
    elsif ( $cmd eq 'end' ) {

        $command_history_index = @command_history ;
    }
    elsif ( $cmd =~ /^[\-\+]\d+$/ ) {

        $command_history_index += $cmd ;
    }
    else { die "whatis $cmd ? " }

    $command_history_index = @command_history if
        $command_history_index > @command_history ;
    $command_history_index = 0 if
        $command_history_index < 0 ;


    if ( $command_history_index == @command_history ) {
        $cmd = $command_history_current ;
    }
    else {
        $cmd = $command_history[ $command_history_index ] ;
    }
    $e->delete(0, 'end') ;
    $e->insert(0, $cmd ) ;
}

sub add_command_history {

    my $cmd  = shift ;

    $command_history_index = @command_history ;
    $command_history_current = '' ;

    return if !$cmd or $cmd !~ /\w/ ;
    return if @command_history and $command_history[ -1] eq $cmd ;

    # ok, doit
    push @command_history, $cmd ;
    $command_history_index++ ;
}

sub ex_gdb_cached {

    my ($key, $val) = @_ ;

    return unless $gdb ;
    return $gdb -> { $key } = $val if defined $val ;
    return $gdb -> { $key } if exists $gdb -> { $key } ;
    return ;
}

sub ex_gdb_sources {

    my $v = gdb_cached 'SourceList' ;
    return $v if $v ;

    my $res = gdb_get ('info sources', 25) ;

    unless ($res =~ /\w/ ) {    # sync bug fix

        telme ("no sources, trying again ..") ;
        sleep 1 ;
        while ($res = gdb_exec_quiet ('') ) {
            sleep 1 ;
        }
                                # and try again ..
        $res = gdb_exec_quiet ('info sources', 20) ;
    }

    my @sources;
    foreach my $line (split /^/, $res) {

        $line =~ /\w/ or next ;
        $line =~ /^\s*Source files/ and next ;
        chomp $line ;
        push @sources,  split /,\s*/, $line ;
    }
    gdb_cached SourceList => \@sources
}

sub ex_gdb_source_map {

    my $v = gdb_cached 'SourceMap';
    return $v if $v;

    $gdb or return telthemloud ("no active debugger");
    my $map = localconfig 'parse-aux-info', $gdb->{'file'};
    gdb_cached SourceMap => $map;
    return $map
}

sub ex_gdb_func_map {

    my $v = gdb_cached 'FuncMap';
    return $v if $v;

    $gdb or return telthemloud ("no active debugger");
    my $map = localconfig 'parse-func-info', $gdb->{'file'};
    gdb_cached FuncMap => $map;
    return $map
}

sub ex_gdb_exec {

    my ($cmd, $timeout) = @_ ;

    exec_this_command( $cmd || '',
                       $text ,
                       $timeout ) ;
}

sub ex_gdb_exec_quiet {
    &gdb_get ;
}

sub ex_gdb_exec_hist {

    my ($cmd, $timeout) = @_ ;
    add_command_history( $cmd ) if $cmd ;
    exec_this_command ($cmd || '',
                       $text,
                       $timeout ) ;
}

sub gdb_get {

    # Perlon: dangerous area! has Perl got answer to Java sync ?
    return unless $gdb ;

    $stopit = 0 ;
    $initial_timeout = 0 ;
    return $gdb -> get (@_) ;
    $stopit = 1 ;

#      if ($semaphore ) {

#          $semaphore -> down ;

#          if ( wantarray() ) {

#              my @res = $gdb -> get ( @_ ) ;

#              $semaphore -> up ;
#              return @res ;
#          }
#          else {

#              my $res = $gdb -> get ( @_ ) ;

#              $semaphore -> up ;
#              return $res ;
#          }
#      }
#      else {

#        return $gdb -> get (@_) ;
#    }
}

sub exec_this_command {

    my ($cmd, $t, $timeout) = @_ ;

    $timeout ||= 9999 ;
    $initial_timeout = 0 ;

    clear_completions($t) ;
    $mainwindow -> idletasks() ;

    $gdb or return telthemloud "no active debugger" ;

    my ($err, $prompt, $result) ;
    $cmd =~ s/^\s+// ;

    # command checkups

    if    ($cmd =~ /^shel?l?\s+(.*)/ ) {

        # Perlon: sending shell command to the debugger might cause
        # the famous 'buffering deadlock' (lookup IPC documents).

        $result = qx($1) || ' ' ;
        $err = $! unless $! =~ /Illegal seek/ ;
        $prompt = ($err || '') . "\n(sgdb)" ;
    }
    elsif ($cmd =~ /^perl\s+(.*)/ ) {

        $result = join "\n:", '', eval $1 ;
        $err = $@ ;
        $prompt = ($err || '') . "\n(sgdb)" ;
    }
    elsif ($cmd =~ /^file?\s+(.*?)\s*$/gi) {

        my $file = $1 ;

        # NOTE: this one might not reach the debugger.

        # Algo: thought it might be nice letting the users opening sources
        # this way (in addition to 'info line my_file.c:1')

        $file =~ s/^\~/$ENV{'HOME'}/e ;
        if (!-e $file ) { return telthemloud "file $file not exists" }
        if (-T  $file ) { return hook_run 'open-source-file', $file  }
        # else:
        $timeout ||= 20 ;
        hook_run( 'new-symbol-file', $file) ;

        # Algo: how to do the right thing for file command? one extreme could be
        # reactivating a new debuger (hook_run('open-new-symbol-file', $file)) to
        # make sure the right debugger is activated, the other could be ignoring
        # this event. I used something in the middle.
    }
    elsif ($cmd =~ /^\s*\.\s*$/ ) {

        hook_run 'refresh-breakpoints' ;
        hook_run 'target-was-switched', gdb_get "info symmetrix-targets" ;
        goto UPDATE_LINE_AND_FRMAE ;
    }
    elsif ( $cmd =~ /^set\s+prompt?\s+(.*?)\s*$/ ) {

        # Algo: it's obvious, isn't it?
        my $newp = $1 ;
        my $oldp = $gdb->{'prompt'} ;
        $gdb->{'prompt' } = qr/$oldp|\Q$newp/s ;
    }
    elsif ( $ENV{symmipSeCrEtIP} ) {
        my $warn =
          $cmd =~ /^\s*symm-c/      ? q/symm-call might risk customer data/ :
          $cmd =~ /^\s*tstar/       ? q/frequent traces might kill the director/ :
          $cmd =~ /^(?:symm-in|inl)/? q/symm-inline shouldn\'t be used on customer box! (use Swuch instead)/ :
          '' ;
        return if $warn and
            askthem ("Warning:\n$warn\n Continue?", 'Cancel', 'Continue') eq 'Cancel' ;
    }

    # whatever it is, go get it...
    ($result, $err, $prompt) = gdb_get ($cmd, $timeout) unless $result or $prompt ;

    $result || $prompt || $err || ($err = '???') ;
    $result ||= gdb_get() ;     # catch std + error stream, just in case
    $prompt ||= "(?SGDB?) " ;

    $prompt = "$err\n$prompt" if $err ;

    # type it as is, or just mention it was repeated ...
    if ( !$result and
         $t -> get ('end -2 l' => 'end') =~
         m[^(\S+\))\s*\Q$cmd\E\s*(?:\(repeated (\d+) times\)|)\n\Q$prompt\E\s*]s
         ) {

        my $pre = $1 ;
        my $num = ($2 || 0) + 1 ;

        $t -> delete ( 'end -2 l' => 'end -2 l lineend' );
        $t -> insert ( 'end -2 l',
                       $pre => 'prompt',
                       $cmd => 'command',
                       " (repeated $num times)" => 'prompt',
                       ) ;
    }
    else {

        if ($secretip_rexp ) {
            $result =~ s/$secretip_rexp/**symmip**/gi ;
            $cmd    =~ s/$secretip_rexp/**symmip**/gi ;
        }
        $cmd =~ s/^(\s*target\s+symmetrix\s+\S+\s+\S+\s+)(\S+)/$1 . ('*' x length $2)/e ;
        # Target 0: "10.243.89.90:D01b  BOpX+jzWDT/g 1nternal"
        # target 0: "10.243.110.129:D08f
        my $res = $result ;
        $res =~ s/^(\s*Target\s+\d+\s*\:\s*\S+\s+\S+\s+)(\S+)\"/ $1 . ('*' x length $2) . '"'/egmi ;
        my $upper_pos = $t->index('end -4 chars') ;
        $t -> insert( 'end',
                      "$cmd\n" => 'command',
                      $res     => 'result',
                      $prompt  => 'prompt',
                      ) ;
        $t->see('end') ;
        $t->see($upper_pos) ;
#         $t -> yview ( 'end' ) ;
    }

    # now, observe the results, errors and commands for cases
    # (this is the dirty part)

    if    ($err and $err eq 'EOF' ) {
                                # capture end of file
        symbol_file_detached() ;
    }
    elsif ($result =~ m[^Line (\d+) of \"(.+?)\"]
           ) {                  # Line 581 of "../lru.c" starts at address 0x5255ac <lock_lru+56> and ends at 0x5255b0 <lock_lru+60>.
                                # source line lookup.

        hook_run( 'open-source-file', $2, $1 ) ;
    }
    elsif ($result =~ m[^\#\d+\s.*\sat\s+(\S+):(\d+)\s*?\n]s  or
           $result =~ m[^Breakpoint (\d+), +\w+ *\(.*\) at (\S+):(\d+)]m
           ) {                  # #0  lock_lru (p_dv=0x8a0000, resource=8585072) at ../lru.c:581
                                # new frame presentation

        goto UPDATE_LINE_AND_FRMAE ;
        # Algo: hmm..., it doesn't looks very smart,
        # is it? but it fixes a bug I founded in gdb's
        # frame display routine.

#          my ($file, $line ) = ($1, $2) ;
#          hook_run( 'open-source-file', $file, $line) ;
#          my ($pc) = gdb_get( 'output/x $pc' ) =~ /(0x[\da-f]{2,})/ ;
#          hook_run( 'new-frame-update', $pc, $line, $file) ;
    }
    elsif ( $result =~ m[^(?:\#\d+\s+)?(0x[a-f\d]+)\s+in\s+\w+\s+\(.*\)\s+at\s+(\S+):(\d+)]om
            #  #1  0xd183c in execute_command (p=0x38b9ac "8", from_tty=1) at ../../sgdb6/gdb/top.c:1554
            ) {
                                # back trace
        my ($pc, $file, $line) = ($1, $2, $3) ;
        hook_run 'open-source-file', $file, $line ;
        hook_run 'new-frame-update', $pc, $file, $line ;
    }
    elsif ($cmd =~ /^tf (?: i | in | ind )?\b /ox and !$err ) {

        # Todo: 'info traced-frame' and hooks run ...
        my $frame = gdb_get( 'info traced-frame' ) ;
        chomp $frame ;

        if ( $frame =~ m[frame\s+\d+\s+in\s+(0x[a-f\d]+).*\)\s+(\S+)\:(\d+)]om
             # frame 0 in 0x5263e0, caused by tracepoint 3 (0 hits) ../lru.c:581.
             ) {

            my ($pcbug, $file, $line) = ($1, $2, $3) ;

            my $pc = gdb_get('output/x $pc') ; # gdb bug fix!! # Todo: fix it in gdb

            hook_run 'open-source-file', $file, $line ;
            hook_run 'new-frame-update', $pc, $file, $line ;

            $frame =~ s/$pcbug/$pc/ ;
        }
        else {
            $t -> bell ;
        }
        telthem $frame ;
        $frame =~ s/,.*// ;
        hook_run 'set-title', 'frame', $frame ;
    }
    elsif ( $cmd =~ /^n (?: i | e  | ex t? )? \b /ox  or
            $cmd =~ /^s (?: i |     tep i? )? \b /ox  ) {
                                # maybe this is a new frame, some data objects might
                                # want to refresh themselves.
UPDATE_LINE_AND_FRMAE:
        my $pc = gdb_get ('output/x $pc', 2 ) ;

        if ( $pc =~ /0x[\da-f]{2,}/ ) {
                                # NOTE: no match for frame zero (0x0)

            my $line =  gdb_get ("i line *$pc") ;

            hook_run( 'open-source-file', $2, $1) if $line =~ m[^Line (\d+) of \"(.+?)\"]o ;
            hook_run( 'new-frame-update', $pc, $2 || '', $1 || '' ) ;
        }
    }
    elsif ( $result =~ m[^Breakpoint (\d+) at (0x[a-f\d]+): file (\S+), line (\d+)]mo
            # Breakpoint 1 at 0x52989c: file ../lru.c, line 2637.
            ) {
        hook_run 'refresh-breakpoints' ;
    }
    elsif ( $result =~ m[^Tracepoint (\d+) at (0x[a-f\d]+): file (\S+), line (\d+)]mo
            # Tracepoint 1 at 0x5263c4: file ../lru.c, line 581.
            ) {
        my ( $num, $addr, $file, $line) = ( $1, $2, $3, $4 ) ;
        hook_run 'set-tracepoint-action', $num, $addr, $file, $line ;
        hook_run 'refresh-breakpoints' ;
    }
    elsif ( $cmd =~ /^d  (?: el e? | elet e? | is a? | isabl e? |) \b /ox or
            $cmd =~ /^en (?: a  b? | abl  e?                     ) \b /ox ) {
        hook_run 'refresh-breakpoints' ;
    }
    elsif ( $result =~ /^Target \d+:\s*\".*\"/mi ) {

        hook_run 'target-was-switched', $result ;

        telthemloud "Watch for MIS-MATCHE's"    if
          ! $in_multi_gdb_cmd                   and
            $cmd =~ /^target\s+symm/i           and
                $gdb->{'file'}                  and
                    $result =~ /^(?:0x|exc0|Target \d+:)/m and
                        gdb_exec( "compare-sections" ) =~ /MIS-MATCH/ ;
    }
    elsif ( $result =~ /^Detach \"(.*)\"/ ) {
        hook_run 'target-was-detached', 'dir', lc $1 ;
        $gdb->{last_dir} = {} ;
    }
    elsif ( $cmd =~ /^tstatu?s?\s*$/o ) {
        hook_run 'mark-tstatus-points', $result ;
    }

    $result ;                   # let it be a return value
}

sub exec_history_command {

    my ($s, $e, $t) = @_ ;

    return $s->bell() if $s -> get() !~ /^\d+$/ ;

    busy ;

    if ( $s->get() != $command_history_index  or
         $command_history_index >= @command_history or
         $e->get() ne $command_history[ $command_history_index ] ) {

        command_history_goto( $s, $e ) ;

    }
    else {

        exec_this_command ($e -> get(), $t ) ;
    }
    unbusy ;
}

sub exec_multi_target_cmd {

    local $in_multi_gdb_cmd = 1;
    my $t = $text ;
    clear_completions( $t ) ;

    # Algo: this sub should should execute commands to all gdb/targets. it should
    # not do it through exec_this_command for avoiding all the snooping. Should it
    # set $gdb and run gdb_get() or should it run $gdb{keys}->get()? the second is
    # more structured, but might bypass gdb_get semaphores and locks.

    my ($allgdb, $alltar, $cmd, $stoper) = map { ref eq 'SCALAR' ? $$_ : $_ } @_ ;
    # Algo: no timeout in this mode. is it needed?

    if    ($stoper ) {
        # stop condition? (string/re/code: stop if 1)
        my $ref = ref $stoper ;
        if  ( ! $ref ) {
            my $re = qr/$stoper/ ;
            $stoper = sub { $_[0] =~ $re } ;
        }
        elsif ( $ref eq 'Regexp') {
            $stoper = sub { $_[0] =~ $stoper } ;
        }
        elsif ( $ref ne 'CODE'  ) {
            die "bad ref stoper: $ref" ;
        }
    }

    my @debuggers ;
    push ( @debuggers, values %gdb ) if $allgdb ;
    push ( @debuggers,        $gdb ) if $gdb and ! grep {$_ == $gdb} @debuggers ;

    @debuggers or return telthemloud "exec_multi: empty gdb list" ;

    my ($currenttarget) = gdb_get( 'i symmetrix-targets' ) =~ /^Target.*\"(.*)\" \(cur/mi ;
    my $currentgdb = $gdb if $allgdb ;

  MGDB: foreach my $d ( @debuggers ) {

        $gdb = $d ;

        $t -> insert ( 'end',
                       "\n" => 'regtext' ,
                       $d -> { 'file' } || '????' => 'switch',
                       ( $alltar ? "\n" : " $cmd\n" ) => 'command' ,
                     ) ;

        if ( $alltar ) {

            # my @targets = gdb_get ( "info symmetrix-targets" ) =~ /\"(.*)\"/g ;
            my @targets = ex_target_symmetrix_list() ;

            foreach my $dir ( @targets ) {

#                 gdb_get ( "target symmetrix $dir" ) ;
                ex_target_symmetrix_chdir ( $dir ) ;
                $initial_timeout = 0 ;
                my $res = $d -> get ( $cmd ) ;
                $dir =~ s/(\S+)\s+.*/$1/ ; # hide credentials

                $t -> insert ( 'end',
                               "\n"      => 'regtext',
                               "($dir) " => 'prompt',
                               " $cmd\n" => 'command',
                               $res      => 'regtext',
                             ) ;

                $stoper and $stoper -> ( $res ) and last MGDB ;
            }
        }
        else {

            my $res = gdb_get ( $cmd ) ;
            $stoper and $stoper -> ( $res ) and last MGDB ;

            $t -> insert ( 'end',
                           "\n"      => 'regtext',
                           $res      => 'regtext',
                         ) ;
        }
        $t -> see ( 'end' ) ;
    }
    # Algo: return $gdb to original target (harmless)
    $gdb = $currentgdb if $currentgdb ;
#     gdb_get ( "target symmetrix $currenttarget" ) if $currenttarget ;
    ex_target_symmetrix_chdir ( $currenttarget ) if $currenttarget ;
    welcome_msg() ;
}

sub exec_entry_command {

    busy ;
    my ($e, $t) = @_ ;

    my $cmd = $e->get ;

    if     ($cmd =~ /^\s*\?+\s*$/) {
                                # explain binding !
        $t->insert('end',
                   explain_me(), 'completions'
                   ) ;
        $t->see('end') ;
    }
    elsif ( $cmd eq '' and
            @command_history and
            $command_history[ -1 ] =~ /^\s*(?:
                                            tf (?: | i | ind?          ) |
                                            n  (?: | i | e | ex | exti?) |
                                            s  (?: | i | te| tepi?     )
                                            )\b /ox ) {
        # Algo: if last command was some kind of stepping
        # then repeat it.
        $cmd = $command_history[ -1 ] ;
        exec_this_command   ($cmd, $t ) ;
    }
    else {

        add_command_history ($cmd) ;
        exec_this_command   ($cmd, $t) ;
    }

    $e->delete(0,'end') ;

    unbusy ;
}

sub gdb_alldone {

    # this routine is called by $gdb at the end of the command

    $interrupter -> configure ( -text => 'INT',
                                pref 'command-prompt-button'
                                ) ;
    $initial_timeout = 0 ;

    $mainwindow -> idletasks() ;
}

sub gdb_notyet  {

    # this one is called every second while waiting for gdb response

    $initial_timeout ++ unless $initial_timeout == 999 ;

    $interrupter -> Unbusy () ;
    $interrupter -> configure ( -text => $initial_timeout,
                                -cursor => 'arrow',
                                -background => 'pink',
                                -activebackground => 'pink2',
                                ) ;

    $mainwindow -> idletasks() ;

    $stopit ;
}

sub new_symbol_file {

    my $t = shift ;

    $t -> configure ( pref 'command-prompt-text' ) ;

    if (@command_history > 4 ) {

        $t -> insert('end' , "\nEND OF SESSION\n\n" => 'prompt' );
    }
    else {

        $t -> delete ('1.0', 'end') ;
    }



    my $b = shift ;
    $b -> configure ( -state => 'normal',
                      pref 'command-prompt-button'
                      ) ;

    my @pref_command_entry =  pref "command-prompt-command-entry" ;

    while ( my $e = shift ) {

        ref $e or last ;
        $e -> configure( -state => 'normal' ,
                         @pref_command_entry
                        );
    }
}

sub symbol_file_detached {

    my $name = $gdb -> { 'file' } ;

    if ( $name ) {

        delete $gdb{ $name } if exists $gdb{ $name } ;
        hook_run 'target-was-detached', 'file',  $name ;
    }

    if ( %gdb ) {

        ( $gdb ) = values %gdb ;
        welcome_msg() ;

        my $targets = gdb_get( "info symmetrix-targets", 2) ;
        hook_run 'target-was-switched', $1 if $targets =~ /\"(.*)\"\s+\(cur/mi ;
    }
    else {
        hook_run 'invalid-symbol-file', $name ;
    }
}

sub invalid_symbol_file {

    eval { foreach my $g ( $gdb, values %gdb ) { destroy $g } } ;
    $gdb = undef ;
    %gdb = () ;

    my $t = shift ;

    $t -> configure (-background => 'grey90' ) ;
    $t -> insert ('end', "\n\nEND OF SESSION" => 'prompt' ) ;
    $t -> see    ('end') ;


    while ( my $e = shift ) {

        next unless ref $e ;
        $e -> configure( -state => 'disabled',
                         -background  => "grey90",
                         );
    }
}

sub clear_completions {

    my $t = shift ;
    if ($t->tagRanges('completions')) {
        $t->delete ('completions.first', 'completions.last') ;
    }
    @last_completions = () ;
    $last_completion_command = '' ;
}

sub show_completions {

    my $t = shift ;
    my $str = shift ;

    clear_completions( $t ) ;

    return unless $str =~ /\S/ ;
    $str =~ s/^\n+// ;
    $str =~ s/\s*\z// ;

    $t -> insert ('end',
                  "completions are:\n$str\n" => 'completions'
                  ) ;

    $t -> see ('end') ;
}

sub explain_me {                # DOC
"Command Prompt Usage:

 ?          - displays this screen
 .          - refresh current frame position in source file

 Enter      - After step: repeat , else: clear buffers
 Tab        - completions (another tab to walk through)
 Up         - previous command
 Down       - next command
 Ctrl + Up/Down/Home/End/Left/Right - allows movement about command panel
 Meta + Up/Down/Home/End/Left/Right - allows movement about source file panel
"
}

sub welcome_msg {

    my $name = $gdb -> { 'file' } || 'welcome' ;

    $name =~ m{(([^/]+)\.elf-gdb |
                ([^/]+)\.elf     |
                ([^/]+))\z       }x  and $name = $1 ;

    $text -> insert ( 'end',
                      "\n"      => 'prompt',
                      "($name)" => 'switch',
                      ' '       => 'prompt',
                      ) ;

    $text -> see ( 'end' ) ;

    hook_run 'set-title', 'file', $name ;
}


sub signal_from_interrupter {

    my $t = shift ;

    $gdb or return telthemloud "No Active debugger, can't signal the void" ;
    $gdb  -> signal ('INT') ;
    $t -> insert ('end' , "\nINT Signal\n" => 'prompt' );

#     sleep 1 ; # OBSOLETE: annoying
    # Perlon: for most system this one only sleeps 'to the top of the second'.
    # that should be enough, because I just want to give gdb a chance to exec.

    ex_gdb_exec() ;
    $stopit = 1 ;
}

#  sub signal_INT_handle {

#      if ( $gdb ) {
#          warn "  sending INT signal to gdb subprocess..\n" ;
#          $gdb -> signal( 'INT' ) ;

#          sleep 1 ;

#          ex_gdb_exec() ;
#      }
#      else {

#          warn "  exit by INT signal\n" ;
#          exit 0 ;
#      }
#      unbusy ;
#  }

sub signal_PIPE_handle {

    telme "got PIPE signal" ;
    telthemloud "PIPE signal from gdb, detaching!" ;
    eval { $gdb -> signal ( -9 ) } ;
    symbol_file_detached() ;
    unbusy ;
}

'end'
